home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
minmax.cls
< prev
next >
Wrap
Text File
|
1997-06-14
|
7KB
|
222 lines
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CMinMax"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Enum EErrorMinMax
eeBaseMinMax = 13120 ' CMinMax
End Enum
Implements ISubclass
Private tx As Long, ty As Long
Private emr As EMsgResponse
Private mmi As MINMAXINFO
Private hWnd As Long
Private Sub Class_Initialize()
' Do object access only once
tx = Screen.TwipsPerPixelX
ty = Screen.TwipsPerPixelY
' Signal default
mmi.ptMaxSize.x = -1
mmi.ptMaxSize.y = -1
mmi.ptMaxPosition.x = -1
mmi.ptMaxPosition.y = -1
mmi.ptMinTrackSize.x = -1
mmi.ptMinTrackSize.y = -1
mmi.ptMaxTrackSize.x = -1
mmi.ptMaxTrackSize.y = -1
End Sub
Private Sub Class_Terminate()
Destroy
End Sub
Sub Create(hWndA As Long)
' Get handle of system menu
hWnd = hWndA
AttachMessage Me, hWndA, WM_GETMINMAXINFO
End Sub
Sub Destroy()
DetachMessage Me, hWnd, WM_GETMINMAXINFO
hWnd = hNull
End Sub
' Interface window procedure method
Private Function ISubclass_WindowProc(ByVal hWnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim mmiT As MINMAXINFO
' Copy parameter to local variable for processing
CopyMemory mmiT, ByVal lParam, LenB(mmiT)
' Subclasser should never call unless it's our message
BugAssert iMsg = WM_GETMINMAXINFO
' Maximized width and height
With mmi.ptMaxSize
If .x <> -1 Then mmiT.ptMaxSize.x = .x
If .y <> -1 Then mmiT.ptMaxSize.y = .y
End With
' Maximized position of top left
With mmi.ptMaxPosition
If .x <> -1 Then mmiT.ptMaxPosition.x = .x
If .y <> -1 Then mmiT.ptMaxPosition.y = .y
End With
' Minimium width and height for sizing
With mmi.ptMinTrackSize
If .x <> -1 Then mmiT.ptMinTrackSize.x = .x
If .y <> -1 Then mmiT.ptMinTrackSize.y = .y
End With
' Maximium width and height for sizing
With mmi.ptMaxTrackSize
If .x <> -1 Then mmiT.ptMaxTrackSize.x = .x
If .y <> -1 Then mmiT.ptMaxTrackSize.y = .y
End With
' Copy modified results back to parameter
CopyMemory ByVal lParam, mmiT, LenB(mmiT)
' Don't pass back to original WindowProc
emr = emrConsume
End Function
' Interface properties
Private Property Get ISubclass_MsgResponse() As EMsgResponse
ISubclass_MsgResponse = emr
End Property
Private Property Let ISubclass_MsgResponse(ByVal emrA As EMsgResponse)
emr = emrA
End Property
Property Get MinWidth() As Long
MinWidth = mmi.ptMinTrackSize.x * tx
End Property
Property Let MinWidth(ByVal dxMinA As Long)
' Must be positive, less than screen, and less than maximum
If dxMinA <= 0 Or dxMinA > Screen.Width Or _
dxMinA > (mmi.ptMaxTrackSize.x * tx) Then Exit Property
mmi.ptMinTrackSize.x = dxMinA / tx
End Property
Property Get MinHeight() As Long
MinHeight = mmi.ptMinTrackSize.y * ty
End Property
Property Let MinHeight(ByVal dyMinA As Long)
' Must be positive, less than screen, and less than maximum
If dyMinA <= 0 Or dyMinA > Screen.Height Or _
dyMinA > (mmi.ptMaxTrackSize.y * ty) Then Exit Property
mmi.ptMinTrackSize.y = dyMinA / ty
End Property
Property Get MaxWidth() As Long
MaxWidth = mmi.ptMaxTrackSize.x * tx
End Property
Property Let MaxWidth(ByVal dxMaxA As Long)
With mmi
' Must be less than screen and greater than minimimum
If dxMaxA > Screen.Width Or dxMaxA < (.ptMinTrackSize.x * tx) Then
Exit Property
End If
.ptMaxTrackSize.x = dxMaxA / tx
' Maximized size can't be greater than maximimum size
If .ptMaxTrackSize.x > .ptMaxSize.x Then .ptMaxSize.x = .ptMaxTrackSize.x
End With
End Property
Property Get MaxHeight() As Long
MaxHeight = mmi.ptMaxTrackSize.y * ty
End Property
Property Let MaxHeight(ByVal dyMaxA As Long)
With mmi
' Must be less than screen and greater than minimimum
If dyMaxA > Screen.Width Or dyMaxA < (.ptMinTrackSize.y * ty) Then
Exit Property
End If
.ptMaxTrackSize.y = dyMaxA / ty
' Maximized size can't be greater than maximimum size
If .ptMaxTrackSize.y > .ptMaxSize.y Then .ptMaxSize.y = .ptMaxTrackSize.y
End With
End Property
Property Get MaximizedWidth() As Long
MaximizedWidth = mmi.ptMaxSize.x * tx
End Property
Property Let MaximizedWidth(ByVal dxMaximizedA As Long)
With mmi
' Must be less than screen and greater than minimimum
If dxMaximizedA > Screen.Width Or _
dxMaximizedA < (.ptMinTrackSize.x * tx) Then Exit Property
.ptMaxSize.x = dxMaximizedA / tx
' Maximized size can't be greater than maximimum size
If .ptMaxSize.x > .ptMaxTrackSize.x Then .ptMaxTrackSize.x = .ptMaxSize.x
End With
End Property
Property Get MaximizedHeight() As Long
MaximizedHeight = mmi.ptMaxSize.y * ty
End Property
Property Let MaximizedHeight(ByVal dyMaximizedA As Long)
With mmi
' Must be less than screen and greater than minimimum
If dyMaximizedA > Screen.Height Or _
dyMaximizedA < (.ptMinTrackSize.y * ty) Then Exit Property
.ptMaxSize.y = dyMaximizedA / ty
' Maximized size can't be greater than maximimum size
If .ptMaxSize.y > .ptMaxTrackSize.y Then .ptMaxTrackSize.y = .ptMaxSize.y
End With
End Property
Property Get MaximizedLeft() As Long
MaximizedLeft = mmi.ptMaxPosition.x * tx
End Property
Property Let MaximizedLeft(ByVal xMaximizedA As Long)
' Must be positive and less than screen (but we won't enforce on
' screen because we don't know property assignment order)
If xMaximizedA < 0 Or xMaximizedA >= Screen.Width Then Exit Property
mmi.ptMaxPosition.x = xMaximizedA / tx
End Property
Property Get MaximizedTop() As Long
MaximizedTop = mmi.ptMaxPosition.y * ty
End Property
Property Let MaximizedTop(ByVal yMaximizedA As Long)
' Must be positive and less than screen (but we won't enforce on
' screen because we don't know property assignment order)
If yMaximizedA < 0 Or yMaximizedA >= Screen.Height Then Exit Property
mmi.ptMaxPosition.y = yMaximizedA / ty
End Property
'
#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
Dim sText As String, sSource As String
If e > 1000 Then
sSource = App.ExeName & ".MinMax"
Select Case e
Case eeBaseMinMax
BugAssert True
' Case ee...
' Add additional errors
End Select
Err.Raise COMError(e), sSource, sText
Else
' Raise standard Visual Basic error
sSource = App.ExeName & ".VBError"
Err.Raise e, sSource
End If
End Sub
#End If